home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / amok_lha / amok13.lha / XHair / XHair.mod < prev    next >
Text File  |  1993-08-15  |  9KB  |  314 lines
  1. (*---------------------------------------------------------------------------
  2.     :Program.    XHair.mod
  3.     :Author.     Fridtjof Siebert
  4.     :Address.    Nobileweg 67, D-7-Stgt-40
  5.     :Phone.      (0)711/822509
  6.     :Shortcut.   [fbs]
  7.     :Version.    1.0
  8.     :Date.       02-Jan-89
  9.     :Copyright.  PD
  10.     :Language.   Modula-II
  11.     :Translator. M2Amiga v3.1d
  12.     :Imports.    arp.library
  13.     :Contents.   Program to replace Mousepointer by a Crosshair
  14.     :Remark.     Same principle as WBPic.mod
  15.     :Usage.      XHair [HELP] [QUIT] [COL HHH] [OLDPTR]
  16. ---------------------------------------------------------------------------*)
  17.  
  18. MODULE XHair;
  19.  
  20. FROM SYSTEM     IMPORT ADR, ADDRESS;
  21. FROM Arts       IMPORT Assert, TermProcedure, wbStarted, dosCmdBuf, dosCmdLen,
  22.                        Terminate;
  23.  
  24. FROM Intuition  IMPORT GetPrefs, ScreenPtr, MakeScreen,
  25.                        RethinkDisplay, Preferences, NewWindow, WindowFlags,
  26.                        WindowFlagSet, ScreenFlags, CloseWindow, ScreenFlagSet,
  27.                        IDCMPFlags, IDCMPFlagSet, OpenWindow, WindowPtr,
  28.                        SetPrefs;
  29. FROM ARP        IMPORT ArpAlloc, CreatePort, Puts, GADS, ArpAllocMem, Delay,
  30.                        DeletePort;
  31. FROM Dos        IMPORT ctrlC;
  32. FROM Exec       IMPORT Forbid, Permit, FindPort, MsgPortPtr, NodeType,
  33.                        Message, MessagePtr, GetMsg, ReplyMsg, PutMsg, Wait,
  34.                        MemReqs, MemReqSet, WaitPort, SetTaskPri, FindTask;
  35. FROM Graphics   IMPORT WaitBOVP, RastPort, BitMap, Move, Draw, InitRastPort,
  36.                        SetDrMd, DrawModes, DrawModeSet, WaitTOF;
  37.  
  38. (*------  CONSTS:  ------*)
  39.  
  40. CONST
  41.   WindowTitle = "XHair © Fridtjof Siebert";
  42.   PortName    = "NewWBPlanes[fbs].Port";
  43.   ReplyName   = "NewWBPlanes[fbs].ReplyPort";
  44.   TPlate      = "HELP/S,QUIT/S,COL/K,OLDPTR/S";
  45.   LTRUE  = -1;
  46.   LFALSE = 0;
  47.  
  48. (*------  TYPES:  ------*)
  49.  
  50. TYPE
  51.   ColorMap =  ARRAY[0..31] OF INTEGER;
  52.   LONGBOOL = LONGINT;
  53.  
  54. (*------  VARS:  ------*)
  55.  
  56. VAR
  57.   WBScreen: ScreenPtr;
  58.   NewPlane: ADDRESS;
  59.   Prefs, NewPrefs: Preferences;
  60.   CMap: ColorMap;
  61.   OldColTable: POINTER TO ColorMap;
  62.   XHairColor: INTEGER;
  63.   Window: WindowPtr;
  64.   NuWindow: NewWindow;
  65.   MyMsg: Message;
  66.   QuitMessage,Msg: MessagePtr;
  67.   MyPort, OldPort: MsgPortPtr;
  68.   Args: RECORD
  69.           help: LONGBOOL;
  70.           quit: LONGBOOL;
  71.           col: POINTER TO ARRAY[0..79] OF CHAR;
  72.           oldptr: LONGBOOL;
  73.         END;
  74.   OldPtr: BOOLEAN;
  75.   NumArgs: INTEGER;
  76.   i: INTEGER;
  77.   oldx,oldy,x,y: INTEGER;
  78.   rp: RastPort;
  79.   bm: BitMap;
  80.   count: CARDINAL;
  81.   in,lastin: BOOLEAN;
  82.   dmacon[0DFF096H]: CARDINAL;
  83.  
  84. (*------  CleanUp:  ------*)
  85.  
  86. PROCEDURE CleanUp();
  87.  
  88. BEGIN
  89.  
  90. (*------  Remove Picture from WB:  ------*)
  91.  
  92.   IF WBScreen#NIL THEN
  93.     Forbid();
  94.       IF OldColTable#NIL THEN
  95.         WBScreen^.viewPort.colorMap^.colorTable := OldColTable;
  96.       END;
  97.       WITH WBScreen^.bitMap DO
  98.         depth := 2;
  99.         planes[2] := NIL;
  100.       END;
  101.       MakeScreen(WBScreen);
  102.     Permit();
  103.     RethinkDisplay();
  104.   END;
  105.  
  106. (*------  Reset Preferences:  ------*)
  107.  
  108.   IF NOT(OldPtr) AND (Prefs.fontHeight>0) THEN
  109.     SetPrefs(ADR(Prefs),SIZE(Preferences),TRUE);
  110.     WaitPort(Window^.userPort);
  111.   END;
  112.  
  113. (*------  Close everything:  ------*)
  114.  
  115.   IF Window#NIL THEN CloseWindow(Window); END;
  116.  
  117. (*------  Remove Port:  ------*)
  118.  
  119.   IF MyPort#NIL THEN
  120.     Forbid();
  121.       IF QuitMessage=NIL THEN QuitMessage := GetMsg(MyPort) END;
  122.       WHILE QuitMessage#NIL DO
  123.         ReplyMsg(QuitMessage);
  124.         QuitMessage := GetMsg(MyPort);
  125.       END;
  126.       DeletePort(MyPort);
  127.     Permit();
  128.   END;
  129.  
  130. END CleanUp;
  131.  
  132. (*------  MAIN:  ------*)
  133.  
  134. BEGIN
  135.  
  136. (*------  Initialization:  ------*)
  137.  
  138.   WBScreen := NIL; OldColTable := NIL; Window := NIL; MyPort := NIL;
  139.   Prefs.fontHeight := 0;
  140.   TermProcedure(CleanUp);
  141.   IF SetTaskPri(FindTask(NIL),5)=0 THEN END;
  142.  
  143. (*------  Have we already been started?  ------*)
  144.  
  145.   OldPort := FindPort(ADR(PortName));
  146.   IF OldPort#NIL THEN
  147.     MyPort := CreatePort(ADR(ReplyName),0);
  148.     Assert(MyPort#NIL,ADR("CreatePort failed"));
  149.     MyMsg.node.type := message;
  150.     MyMsg.replyPort := MyPort;
  151.     PutMsg(OldPort,ADR(MyMsg)); (* Signal task to quit *)
  152.     WaitPort(MyPort);
  153.     DeletePort(MyPort);
  154.     MyPort := NIL;
  155.     IF wbStarted THEN
  156.       Terminate(0);
  157.     ELSE
  158.       IF Puts(ADR("Task signalled"))=0 THEN END;
  159.     END;
  160.   END;
  161.   MyPort := CreatePort(ADR(PortName),0);
  162.   Assert(MyPort#NIL,ADR("CreatePort failed"));
  163.  
  164. (*------  Open Window:  ------*)
  165.  
  166.   WITH NuWindow DO
  167.     leftEdge   := 0; topEdge     := 0;
  168.     width      := 1; height      := 1;
  169.     detailPen  := 0; blockPen    := 1;
  170.     idcmpFlags := IDCMPFlagSet{newPrefs};
  171.     flags      := WindowFlagSet{backDrop};
  172.     firstGadget:= NIL; checkMark := NIL;
  173.     title      := ADR(WindowTitle);
  174.     screen     := NIL; bitMap    := NIL;
  175.     type       := ScreenFlagSet{wbenchScreen};
  176.   END;
  177.   Window := OpenWindow(NuWindow);
  178.   Assert(Window#NIL,ADR("Can't open Window!!!"));
  179.   WBScreen := Window^.wScreen;
  180.   IF WBScreen^.bitMap.depth>2 THEN
  181.     IF Puts(ADR("There's something strange with your Workbench!"))=0 THEN END;
  182.     Terminate(0);
  183.   END;
  184.  
  185. (*------  Get Arguments:  ------*)
  186.  
  187.   XHairColor := -1; OldPtr := FALSE;
  188.   IF NOT wbStarted THEN
  189.     WITH Args DO
  190.       help := LFALSE;
  191.       quit := LFALSE;
  192.       col  := NIL;
  193.       oldptr := LFALSE;
  194.     END;
  195.     NumArgs := GADS(dosCmdBuf,dosCmdLen,NIL,ADR(Args),ADR(TPlate));
  196.     WITH Args DO
  197.       IF (NumArgs=-1) THEN
  198.         IF Puts(ADR("Bad Args"))=0 THEN END;
  199.         Terminate(0);
  200.       END;
  201.       IF help=LTRUE THEN
  202.         IF Puts(ADR("Usage: XHair [HELP] [QUIT] [COL HHH] [OLDPTR]")) +
  203.            Puts(ADR("  HELP    Shows usage")) +
  204.            Puts(ADR("  QUIT    Signals XHair to quit")) +
  205.            Puts(ADR("  COL HHH Set XHair's color to hex # HHH")) +
  206.            Puts(ADR("  OLDPTR  aviods removing pointer"))=0 THEN END;
  207.         Terminate(0);
  208.       END;
  209.       IF quit=LTRUE THEN Terminate(0) END;
  210.       IF (col#NIL) THEN
  211.         XHairColor := 0;
  212.         IF col^[3]#0C THEN
  213.           IF Puts(ADR("Bad Args"))=0 THEN END;
  214.           Terminate(0);
  215.         END;
  216.         FOR i:=0 TO 2 DO
  217.           XHairColor := XHairColor * 16;
  218.           CASE CAP(col^[i]) OF
  219.           "0".."9": INC(XHairColor,ORD(    col^[i] )-ORD("0")   ); |
  220.           "A".."F": INC(XHairColor,ORD(CAP(col^[i]))-ORD("A")+10); |
  221.           ELSE
  222.             IF Puts(ADR("Bad Args"))=0 THEN END;
  223.             Terminate(0);
  224.           END;
  225.         END;
  226.       END;
  227.       OldPtr := (oldptr=LTRUE);
  228.     END;
  229.   END;
  230.  
  231. (*------  Modify Preferences:  ------*)
  232.  
  233.   IF NOT OldPtr THEN
  234.     GetPrefs(ADR(Prefs),SIZE(Preferences));
  235.     NewPrefs := Prefs;
  236.     WITH NewPrefs DO
  237.       FOR i:=2 TO 33 DO
  238.         pointerMatrix[i] := 0;
  239.       END;
  240.       color17 := color0;
  241.       color18 := color0;
  242.       color19 := color0;
  243.     END;
  244.     SetPrefs(ADR(NewPrefs),SIZE(Preferences),TRUE);
  245.   END;
  246.  
  247. (*------  Set Colors:  ------*)
  248.  
  249.   Forbid();
  250.   OldColTable := WBScreen^.viewPort.colorMap^.colorTable;
  251.   CMap := OldColTable^;
  252.   IF XHairColor=-1 THEN
  253.     FOR i:=0 TO 3 DO CMap[4+i]:=CMap[3-i] END;
  254.   ELSE
  255.     FOR i:=4 TO 7 DO CMap[i]:=XHairColor END;
  256.   END;
  257.   WBScreen^.viewPort.colorMap^.colorTable := ADR(CMap);
  258.   Permit();
  259.  
  260. (*------  Add Plane to WBScreen:  ------*)
  261.  
  262.   WITH WBScreen^.bitMap DO
  263.     NewPlane := ArpAllocMem(rows*bytesPerRow,MemReqSet{chip,memClear});
  264.     Assert(NewPlane#NIL,ADR("Out of memory"));
  265.     planes[2] := NewPlane;
  266.   END;
  267.  
  268. (*------  Init dummy RastPort:  ------*)
  269.  
  270.   InitRastPort(rp);
  271.   rp.bitMap := ADR(bm);
  272.   bm := WBScreen^.bitMap;
  273.   bm.depth := 1;
  274.   bm.planes[0] := NewPlane;
  275.   SetDrMd(ADR(rp),DrawModeSet{complement});
  276.  
  277. (*------  Do it:  ------*)
  278.  
  279.   WITH WBScreen^ DO
  280.     WITH bitMap DO
  281.       count := 0; lastin := FALSE;
  282.       REPEAT
  283.         WaitTOF();
  284.         IF NOT OldPtr THEN dmacon := 32 END; (* = GfxMacros.OffSprite *)
  285.         x := mouseX; y := mouseY;
  286.         in := (x>=0) AND (x<width) AND (y>=0) AND (y<height);
  287.         INC(count);
  288.         IF in AND NOT(lastin) OR (count=50) THEN
  289.           Forbid();
  290.             depth := 3;
  291.             MakeScreen(WBScreen);
  292.             depth := 2;
  293.             RethinkDisplay();
  294.           Permit();
  295.           count := 0;
  296.         END;
  297.         IF (oldx#x) OR (in#lastin) THEN
  298.           IF in     THEN Move(ADR(rp),   x,0); Draw(ADR(rp),   x,height-1) END;
  299.           IF lastin THEN Move(ADR(rp),oldx,0); Draw(ADR(rp),oldx,height-1) END;
  300.           oldx := x;
  301.         END;
  302.         IF (oldy#y) OR (in#lastin) THEN
  303.           IF in     THEN Move(ADR(rp),0,y);    Draw(ADR(rp),width-1,y)    END;
  304.           IF lastin THEN Move(ADR(rp),0,oldy); Draw(ADR(rp),width-1,oldy) END;
  305.           oldy := y;
  306.         END;
  307.         lastin := in;
  308.         QuitMessage := GetMsg(MyPort);
  309.       UNTIL QuitMessage#NIL;
  310.     END;
  311.   END;
  312.  
  313. END XHair.
  314.